home *** CD-ROM | disk | FTP | other *** search
/ CU Amiga Super CD-ROM 24 / CU Amiga Magazine's Super CD-ROM 24 (1998)(EMAP Images)(GB)(Track 1 of 2)[!][issue 1998-07].iso / CUCD / Programming / SWI / 68000 / boot / dwim.pl < prev    next >
Encoding:
Text File  |  1997-10-13  |  9.0 KB  |  293 lines
  1. /*  $Id: dwim.pl,v 1.6 1997/10/13 10:07:17 jan Exp $
  2.  
  3.     Copyright (c) 1990 Jan Wielemaker. All rights reserved.
  4.     jan@swi.psy.uva.nl
  5.  
  6.     Purpose: Introduce `Do What I Mean' (DWIM) correction
  7. */
  8.  
  9. :- module($dwim,
  10.     [ dwim_predicate/2
  11.     , $dwim_correct_goal/3
  12.     , $find_predicate/2
  13.     , $similar_module/2
  14.     ]).
  15.  
  16. :- module_transparent
  17.     $dwim_correct_goal/3, 
  18.     correct_goal/4.
  19.  
  20. %    $dwim_correct_goal(+Goal, +Bindings, -Corrected)
  21. %    Correct a goal (normally typed by the user) in the `Do What I Mean'
  22. %    sence. Ask the user to confirm if the a unique correction can be
  23. %    found. Otherwise warn that the predicate does not exist and fail.
  24.  
  25. $dwim_correct_goal(Goal, _, Goal) :-        % Not instantiated. Hope it
  26.     var(Goal), !.                % will be in time
  27. $dwim_correct_goal((A,B), Bindings, (NA,NB)) :- !,
  28.     $dwim_correct_goal(A, Bindings, NA),
  29.     $dwim_correct_goal(B, Bindings, NB).
  30. $dwim_correct_goal((A->B;C), Bindings, (NA->NB;NC)) :- !,
  31.     $dwim_correct_goal(A, Bindings, NA),
  32.     $dwim_correct_goal(B, Bindings, NB),
  33.     $dwim_correct_goal(C, Bindings, NC).
  34. $dwim_correct_goal((A*->B;C), Bindings, (NA*->NB;NC)) :- !,
  35.     $dwim_correct_goal(A, Bindings, NA),
  36.     $dwim_correct_goal(B, Bindings, NB),
  37.     $dwim_correct_goal(C, Bindings, NC).
  38. $dwim_correct_goal((A;B), Bindings, (NA;NB)) :- !,
  39.     $dwim_correct_goal(A, Bindings, NA),
  40.     $dwim_correct_goal(B, Bindings, NB).
  41. $dwim_correct_goal(\+(A), Bindings, \+(NA)) :- !,
  42.     $dwim_correct_goal(A, Bindings, NA).
  43. $dwim_correct_goal(Module:Goal, _, Module:Goal) :-
  44.     (var(Module) ; var(Goal)), !.
  45. $dwim_correct_goal(Goal, _, Goal) :-        % is defined
  46.     current_predicate(_, Goal), !.
  47. $dwim_correct_goal(Goal, Bindings, NewGoal) :-    % correct the goal
  48.     dwim_predicate_list(Goal, DWIMs), !,
  49.     correct_goal(Goal, Bindings, DWIMs, NewGoal).
  50. $dwim_correct_goal(Goal, _, _) :-        % can't be corrected
  51.     $break($warn_undefined(Goal, [])),
  52.     fail.
  53.  
  54. correct_goal(Goal, Bindings, [Dwim], DwimGoal) :-
  55.     $strip_module(Goal, _, G1), 
  56.     $strip_module(Dwim, DM, G2), 
  57.     functor(G1, _, Arity), 
  58.     functor(G2, Name, Arity), !, 
  59.     G1 =.. [_|Arguments], 
  60.     G2 =.. [Name|Arguments], 
  61.     context_module(Context),
  62.     $prefix_module(DM, Context, G2, DwimGoal),
  63.     goal_name(DwimGoal, Bindings, String),
  64.     $confirm('Correct to: `~w''', [String]).
  65. correct_goal(Goal, Bindings, Dwims, NewGoal) :-
  66.     $strip_module(Goal, _, G1), 
  67.     functor(G1, _, Arity), 
  68.     sublist($dwim:has_arity(Arity), Dwims, [Dwim]), !,
  69.     correct_goal(Goal, Bindings, [Dwim], NewGoal).
  70. correct_goal(Goal, _, Dwims, _) :-
  71.     $break($warn_undefined(Goal, Dwims)), 
  72.     fail.
  73.  
  74. has_arity(A, G) :-
  75.     $strip_module(G, _, G1), 
  76.     functor(G1, _, A).
  77.  
  78. %    goal_name(+Goal, +Bindings, -Name)
  79. %    Transform Goal into a readable format.
  80.  
  81. goal_name(Goal, Bindings, String) :-
  82.     checklist(call, Bindings),        % Bind the variables
  83.     goal_name_(Goal, String),
  84.     recorda($goal_name, String),
  85.     fail.
  86. goal_name(_, _, String) :-
  87.     recorded($goal_name, String, Ref), !,
  88.     erase(Ref).
  89.  
  90. goal_name_('_', '_') :- !.            % catch anonemous variable
  91. goal_name_(Module:Name/Arity, String) :- !,
  92.     sformat(String, '~q:~q/~q', [Module, Name, Arity]).
  93. goal_name_(Name/Arity, String) :- !,
  94.     sformat(String, '~q/~q', [Name, Arity]).
  95. goal_name_(Module:Term, String) :- !,
  96.     sformat(String, '~q:~w', [Module, Term]).
  97. goal_name_(Goal, String) :-
  98.     sformat(String, '~w', [Goal]).
  99.  
  100.  
  101. %    $find_predicate(+Spec, -List)
  102. %
  103. %    Unify `List' with a list  of  predicate  heads  that  match  the
  104. %    specification  `Spec'.  `Spec' is a term Name/Arity, a ``Head'', 
  105. %    or just an atom.  The latter refers to  all  predicate  of  that
  106. %    name with arbitrary arity.  `Do What I Mean' correction is done.
  107. %    If the requested module is `user' predicates residing in any
  108. %    module will be considered matching.
  109. %    If  no predicates can be found or more than one `Do What I Mean'
  110. %    solution exists an error message is displayed.
  111.  
  112. :- module_transparent
  113.     $find_predicate/2.
  114.  
  115. $find_predicate(Spec, List) :-
  116.     $strip_module(Spec, M, S),
  117.     name_arity(S, Name, Arity),
  118.     context_module(C),
  119.     (   M == user
  120.     ;   Module = M
  121.     ) ->
  122.     find_predicate(Module, C, Name, Arity, L0), !,
  123.     sort(L0, L1),
  124.     principal_predicates(C, L1, List).
  125. $find_predicate(Spec, List) :-
  126.     $strip_module(Spec, _M, S),
  127.     name_arity(S, Name, Arity),
  128.     findall(Head, ('$in_library'(Name, Arity),
  129.                functor(Head, Name, Arity)), List),
  130.     List \== [], !.
  131. $find_predicate(Spec, _) :-
  132.     $warning('No predicates for `~w''', [Spec]),
  133.     fail.
  134.     
  135. find_predicate(Module, C, Name, Arity, VList) :-
  136.     findall(Head, find_predicate_(Module, C, Name, Arity, Head), VList),
  137.     VList \== [], !.
  138. find_predicate(Module, C, Name, Arity, Pack) :-
  139.     findall(Head, find_sim_pred(Module, Name, Arity, Head), List),
  140.     pack(List, Module, Arity, C, Packs),
  141.     member(Dwim-Pack, Packs),
  142.     print_pack_name(C, Dwim, PredName),
  143.     $confirm('Correct to `~w''', PredName), !.
  144.  
  145. print_pack_name(C, C:Name/Arity, P) :- !, concat_atom([Name, /, Arity], P).
  146. print_pack_name(_, M:Name/Arity, P) :- !, concat_atom([M, :, Name, /, Arity], P).
  147. print_pack_name(C, C:Name, Name)    :- !.
  148. print_pack_name(_, M:Name, P)       :- !, concat_atom([M, :, Name], P).
  149. print_pack_name(_, Name,   Name).
  150.  
  151.  
  152. %    pack(+Heads, +Context, -Packs)
  153. %    Pack the list of heads into packets, consisting of the corrected
  154. %    specification and a list of heads meeting this specification.
  155.  
  156. pack([], _, _, _, []) :- !.
  157. pack([M:T|Rest], Module, Arity, C, [Name-[H|R]|Packs]) :-
  158.     $prefix_module(M, C, T, H),
  159.     pack_name(M:T, Module, Arity, Name),
  160.     pack_(Module, Arity, Name, C, Rest, R, NewRest),
  161.     pack(NewRest, Module, Arity, C, Packs).
  162.  
  163. pack_(Module, Arity, Name, C, List, [H|R], Rest) :-
  164.     select(List, M:T, R0),
  165.     pack_name(M:T, Module, Arity, Name), !,
  166.     $prefix_module(M, C, T, H),
  167.     pack_(Module, Arity, Name, C, R0, R, Rest).
  168. pack_(_, _, _, _, Rest, [], Rest).
  169.  
  170. pack_name(_:T, V1, V2,   Name)   :- var(V1), var(V2), !, functor(T, Name, _).
  171. pack_name(M:T,  _, V2, M:Name)   :-          var(V2), !, functor(T, Name, _).
  172. pack_name(_:T, V1,  _, Name/A)   :- var(V1),          !, functor(T, Name, A).
  173. pack_name(M:T,  _,  _, M:Name/A) :-                      functor(T, Name, A).
  174.  
  175.  
  176. find_predicate_(M, C, Name, Arity, Head) :-
  177.     same_module(M, Module),
  178.     current_predicate(Name, Module:Term),
  179.     functor(Term, Name, A),
  180.     same_arity(Arity, A),
  181.     $prefix_module(Module, C, Term, Head).
  182.  
  183. same_module(M, Module) :-
  184.     var(M), !,
  185.     current_module(Module).
  186. same_module(M, M) :-
  187.     current_module(M).
  188.  
  189. same_arity(A, _) :- var(A), !.
  190. same_arity(A, A).
  191.  
  192. find_sim_pred(M, Name, Arity, Module:Term) :-
  193.     sim_module(M, Module),
  194.     $dwim_predicate(Module:Name, Term),
  195.     functor(Term, _, DArity),
  196.     sim_arity(Arity, DArity).
  197.     
  198. sim_module(M, Module) :-
  199.     var(M), !,
  200.     current_module(Module).
  201. sim_module(M, M) :-
  202.     current_module(M), !.
  203. sim_module(M, Module) :-
  204.     current_module(Module),
  205.     dwim_match(M, Module).
  206.  
  207. sim_arity(A, _) :- var(A), !.
  208. sim_arity(A, D) :- abs(A-D) < 2.
  209.  
  210. %    name_arity(+Spec, -Name, -Arity)
  211. %    Obtain the name and arity of a predicate specification. Warn if
  212. %    this is not a legal specification.
  213.  
  214. name_arity(Atom, Atom, _) :-
  215.     atom(Atom), !.
  216. name_arity(Name/Arity, Name, Arity) :- !.
  217. name_arity(Term, Name, Arity) :-
  218.     functor(Term, Name, Arity), !.
  219. name_arity(Spec, _, _) :-
  220.     $warning('Illegal predicate specification: `~w''', [Spec]),
  221.     fail.
  222.  
  223.  
  224. %    principal_predicates(+Context, +Heads, -Principals)
  225. %    Get the principal predicate list from a list of heads (e.g. the
  226. %    module in which the predicate is defined).
  227.  
  228. principal_predicates(C, Heads, Principals) :-
  229.     maplist(find_definition(C), Heads, P0),
  230.     (   C == user
  231.     ->  maplist(find_public, P0, P1),
  232.         delete_defaults(P1, P1, P2)
  233.     ;   P2 = P0
  234.     ),    
  235.     list_to_set(P2, Principals).
  236.     
  237. delete_defaults([], _, []) :- !.
  238. delete_defaults([system:Head|T], L, R) :-
  239.     memberchk(Head, L), !,
  240.     delete_defaults(T, L, R).
  241. delete_defaults([H|T], L, [H|R]) :-
  242.     delete_defaults(T, L, R).
  243.  
  244. find_public(Head, user:Term) :-
  245.     $strip_module(Head, M, Term),
  246.     current_predicate(_, user:Term),
  247.     $predicate_property(imported_from(M), user:Term), !.
  248. find_public(Head, Head).
  249.  
  250. find_definition(C, Head, Principal) :-
  251.     $predicate_property(imported_from(Module), C:Head), !,
  252.     $strip_module(Head, _, Term),
  253.     $prefix_module(Module, C, Term, P0),
  254.     find_definition(C, P0, Principal).
  255. find_definition(_, Head, Head).
  256.  
  257.  
  258. %    dwim_predicate(+Head, -NewHead)
  259. %    Find a head that is in a `Do What I Mean' sence the same as `Head'.
  260. %    backtracking produces more such predicates.
  261.  
  262. :- module_transparent
  263.     dwim_predicate/2, 
  264.     dwim_predicate_list/2.
  265.  
  266. dwim_predicate(Head, DWIM) :-
  267.     dwim_predicate_list(Head, DWIMs),
  268.     member(DWIM, DWIMs).
  269.  
  270. dwim_predicate_list(Head, [Head]) :-
  271.     current_predicate(_, Head), !.
  272. dwim_predicate_list(Head, DWIMs) :-
  273.     context_module(C),
  274.     setof(DWIM, $dwim:dwim_pred(C:Head, DWIM), DWIMs), !.
  275. dwim_predicate_list(Head, DWIMs) :-
  276.     setof(DWIM, $similar_module(Head, DWIM), DWIMs), !.
  277. dwim_predicate_list(Head, DWIMs) :-
  278.     $strip_module(Head, _, Goal),
  279.     setof(Module:Goal, ( current_module(Module),
  280.                  current_predicate(_, Module:Goal)
  281.                ), DWIMs).
  282.  
  283. dwim_pred(Head, Dwim) :-
  284.     '$strip_module'(Head, Module, H),
  285.     default_module(Module, M),
  286.     '$dwim_predicate'(M:H, Dwim).
  287.  
  288. $similar_module(Head, DwimModule:Goal) :-
  289.     $strip_module(Head, Module, Goal),
  290.     current_module(DwimModule),
  291.     dwim_match(Module, DwimModule),
  292.     current_predicate(_, DwimModule:Goal).
  293.